home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / emacs_src_18_58.lha / emacs-18.58 / lisp / sun-mouse.el < prev    next >
Lisp/Scheme  |  1992-02-21  |  24KB  |  671 lines
  1. ;; Mouse handling for Sun windows
  2. ;; Copyright (C) 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;;; Jeff Peck, Sun Microsystems, Jan 1987.
  21. ;;; Original idea by Stan Jefferson
  22.  
  23. (provide 'sun-mouse)
  24.  
  25. ;;;
  26. ;;;     Modelled after the GNUEMACS keymap interface.
  27. ;;;
  28. ;;; User Functions:
  29. ;;;   make-mousemap, copy-mousemap, 
  30. ;;;   define-mouse, global-set-mouse, local-set-mouse,
  31. ;;;   use-global-mousemap, use-local-mousemap,
  32. ;;;   mouse-lookup, describe-mouse-bindings
  33. ;;;
  34. ;;; Options:
  35. ;;;   extra-click-wait, scrollbar-width
  36. ;;;
  37.  
  38. (defvar extra-click-wait 150
  39.   "*Number of milliseconds to wait for an extra click.
  40. Set this to zero if you don't want chords or double clicks.")
  41.  
  42. (defvar scrollbar-width 5
  43.   "*The character width of the scrollbar.
  44. The cursor is deemed to be in the right edge scrollbar if it is this near the
  45. right edge, and more than two chars past the end of the indicated line.
  46. Setting to nil limits the scrollbar to the edge or vertical dividing bar.")
  47.  
  48. ;;;
  49. ;;; Mousemaps
  50. ;;;
  51. (defun make-mousemap ()
  52.   "Returns a new mousemap."
  53.   (cons 'mousemap nil))
  54.  
  55. (defun copy-mousemap (mousemap)
  56.   "Return a copy of mousemap."
  57.   (copy-alist mousemap))
  58.  
  59. (defun define-mouse (mousemap mouse-list def)
  60.   "Args MOUSEMAP, MOUSE-LIST, DEF.  Define MOUSE-LIST in MOUSEMAP as DEF.
  61. MOUSE-LIST is a list of atoms specifing a mouse hit according to these rules:
  62.   * One of these atoms specifies the active region of the definition.
  63.     text, scrollbar, modeline, minibuffer
  64.   * One or two or these atoms specify the button or button combination.
  65.         left, middle, right, double
  66.   * Any combination of these atoms specify the active shift keys.
  67.         control, shift, meta
  68.   * With a single unshifted button, you can add
  69.     up
  70.     to indicate an up-click.
  71. The atom `double' is used with a button designator to denote a double click.
  72. Two button chords are denoted by listing the two buttons.
  73. See sun-mouse-handler for the treatment of the form DEF."
  74.   (mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def))
  75.  
  76. (defun global-set-mouse (mouse-list def)
  77.   "Give MOUSE-EVENT-LIST a local definition of DEF.
  78. See define-mouse for a description of MOUSE-EVENT-LIST and DEF.
  79. Note that if MOUSE-EVENT-LIST has a local definition in the current buffer,
  80. that local definition will continue to shadow any global definition."
  81.   (interactive "xMouse event: \nxDefinition: ")
  82.   (define-mouse current-global-mousemap mouse-list def))
  83.  
  84. (defun local-set-mouse (mouse-list def)
  85.   "Give MOUSE-EVENT-LIST a local definition of DEF.
  86. See define-mouse for a description of the arguments.
  87. The definition goes in the current buffer's local mousemap.
  88. Normally buffers in the same major mode share a local mousemap."
  89.   (interactive "xMouse event: \nxDefinition: ")
  90.   (if (null current-local-mousemap)
  91.       (setq current-local-mousemap (make-mousemap)))
  92.   (define-mouse current-local-mousemap mouse-list def))
  93.  
  94. (defun use-global-mousemap (mousemap)
  95.   "Selects MOUSEMAP as the global mousemap."
  96.   (setq current-global-mousemap mousemap))
  97.  
  98. (defun use-local-mousemap (mousemap)
  99.   "Selects MOUSEMAP as the local mousemap.
  100. nil for MOUSEMAP means no local mousemap."
  101.   (setq current-local-mousemap mousemap))
  102.  
  103.  
  104. ;;;
  105. ;;; Interface to the Mouse encoding defined in Emacstool.c
  106. ;;;
  107. ;;; Called when mouse-prefix is sent to emacs, additional
  108. ;;; information is read in as a list (button x y time-delta)
  109. ;;;
  110. ;;; First, some generally useful functions:
  111. ;;;
  112.  
  113. (defun logtest (x y)
  114.   "True if any bits set in X are also set in Y.
  115. Just like the Common Lisp function of the same name."
  116.   (not (zerop (logand x y))))
  117.  
  118.  
  119. ;;;
  120. ;;; Hit accessors.
  121. ;;;
  122.  
  123. (defconst sm::ButtonBits 7)        ; Lowest 3 bits.
  124. (defconst sm::ShiftmaskBits 56)        ; Second lowest 3 bits (56 = 63 - 7).
  125. (defconst sm::DoubleBits 64)        ; Bit 7.
  126. (defconst sm::UpBits 128)        ; Bit 8.
  127.  
  128. ;;; All the useful code bits
  129. (defmacro sm::hit-code (hit)
  130.   (` (nth 0 (, hit))))
  131. ;;; The button, or buttons if a chord.
  132. (defmacro sm::hit-button (hit)
  133.   (` (logand sm::ButtonBits (nth 0 (, hit)))))
  134. ;;; The shift, control, and meta flags.
  135. (defmacro sm::hit-shiftmask (hit)
  136.   (` (logand sm::ShiftmaskBits (nth 0 (, hit)))))
  137. ;;; Set if a double click (but not a chord).
  138. (defmacro sm::hit-double (hit)
  139.   (` (logand sm::DoubleBits (nth 0 (, hit)))))
  140. ;;; Set on button release (as opposed to button press).
  141. (defmacro sm::hit-up (hit)
  142.   (` (logand sm::UpBits (nth 0 (, hit)))))
  143. ;;; Screen x position.
  144. (defmacro sm::hit-x (hit) (list 'nth 1 hit))
  145. ;;; Screen y position.
  146. (defmacro sm::hit-y (hit) (list 'nth 2 hit))
  147. ;;; Millisconds since last hit.
  148. (defmacro sm::hit-delta (hit) (list 'nth 3 hit))
  149.  
  150. (defmacro sm::hit-up-p (hit)        ; A predicate.
  151.   (` (not (zerop (sm::hit-up (, hit))))))
  152.  
  153. ;;;
  154. ;;; Loc accessors.  for sm::window-xy
  155. ;;;
  156. (defmacro sm::loc-w (loc) (list 'nth 0 loc))
  157. (defmacro sm::loc-x (loc) (list 'nth 1 loc))
  158. (defmacro sm::loc-y (loc) (list 'nth 2 loc))
  159.  
  160. (defmacro eval-in-buffer (buffer &rest forms)
  161.   "Macro to switches to BUFFER, evaluates FORMS, returns to original buffer."
  162.   ;; When you don't need the complete window context of eval-in-window
  163.   (` (let ((StartBuffer (current-buffer)))
  164.     (unwind-protect
  165.     (progn
  166.       (set-buffer (, buffer))
  167.       (,@ forms))
  168.     (set-buffer StartBuffer)))))
  169.  
  170. (put 'eval-in-buffer 'lisp-indent-hook 1)
  171.  
  172. ;;; this is used extensively by sun-fns.el
  173. ;;;
  174. (defmacro eval-in-window (window &rest forms)
  175.   "Switch to WINDOW, evaluate FORMS, return to original window."
  176.   (` (let ((OriginallySelectedWindow (selected-window)))
  177.        (unwind-protect
  178.        (progn
  179.          (select-window (, window))
  180.          (,@ forms))
  181.      (select-window OriginallySelectedWindow)))))
  182. (put 'eval-in-window 'lisp-indent-hook 1)
  183.  
  184. ;;;
  185. ;;; handy utility, generalizes window_loop
  186. ;;;
  187.  
  188. ;;; It's a macro (and does not evaluate its arguments).
  189. (defmacro eval-in-windows (form &optional yesmini)
  190.   "Switches to each window and evaluates FORM.  Optional argument
  191. YESMINI says to include the minibuffer as a window.
  192. This is a macro, and does not evaluate its arguments."
  193.   (` (let ((OriginallySelectedWindow (selected-window)))
  194.        (unwind-protect 
  195.        (while (progn
  196.             (, form)
  197.             (not (eq OriginallySelectedWindow
  198.                  (select-window
  199.                   (next-window nil (, yesmini)))))))
  200.      (select-window OriginallySelectedWindow)))))
  201. (put 'eval-in-window 'lisp-indent-hook 0)
  202.  
  203. (defun move-to-loc (x y)
  204.   "Move cursor to window location X, Y.
  205. Handles wrapped and horizontally scrolled lines correctly."
  206.   (move-to-window-line y)
  207.   ;; window-line-end expects this to return the window column it moved to.
  208.   (let ((cc (current-column))
  209.     (nc (move-to-column
  210.          (if (zerop (window-hscroll))
  211.          (+ (current-column)
  212.             (min (- (window-width) 2)    ; To stay on the line.
  213.              x))
  214.            (+ (window-hscroll) -1
  215.           (min (1- (window-width))    ; To stay on the line.
  216.                x))))))
  217.     (- nc cc)))
  218.  
  219.  
  220. (defun minibuffer-window-p (window)
  221.   "True iff this WINDOW is minibuffer."
  222.   (= (screen-height)
  223.      (nth 3 (window-edges window))    ; The bottom edge.
  224.      ))
  225.  
  226.  
  227. (defun sun-mouse-handler (&optional hit)
  228.   "Evaluates the function or list associated with a mouse hit.
  229. Expecting to read a hit, which is a list: (button x y delta).  
  230. A form bound to button by define-mouse is found by mouse-lookup. 
  231. The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound.  
  232. If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*,
  233. *mouse-x*, and *mouse-y* as arguments; if the form is a list (listp),
  234. the form is eval'ed; if the form is neither of these, it is an error.
  235. Returns nil."
  236.   (interactive)
  237.   (if (null hit) (setq hit (sm::combined-hits)))
  238.   (let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit))))
  239.     (let ((*mouse-window* (sm::loc-w loc))
  240.       (*mouse-x* (sm::loc-x loc))
  241.       (*mouse-y* (sm::loc-y loc))
  242.       (mouse-code (mouse-event-code hit loc)))
  243.       (let ((form (eval-in-buffer (window-buffer *mouse-window*)
  244.             (mouse-lookup mouse-code))))
  245.     (cond ((null form)
  246.            (if (not (sm::hit-up-p hit))    ; undefined up hits are ok.
  247.            (error "Undefined mouse event: %s" 
  248.               (prin1-to-string 
  249.                (mouse-code-to-mouse-list mouse-code)))))
  250.           ((symbolp form)
  251.            (setq this-command form)
  252.            (funcall form *mouse-window* *mouse-x* *mouse-y*))
  253.           ((listp form)
  254.            (setq this-command (car form))
  255.            (eval form))
  256.           (t
  257.            (error "Mouse action must be symbol or list, but was: %s"
  258.               form))))))
  259.   ;; Don't let 'sun-mouse-handler get on last-command,
  260.   ;; since this function should be transparent.
  261.   (if (eq this-command 'sun-mouse-handler)
  262.       (setq this-command last-command))
  263.   ;; (message (prin1-to-string this-command))    ; to see what your buttons did
  264.   nil)
  265.  
  266. (defun sm::combined-hits ()
  267.   "Read and return next mouse-hit, include possible double click"
  268.   (let ((hit1 (mouse-hit-read)))
  269.     (if (not (sm::hit-up-p hit1))    ; Up hits dont start doubles or chords.
  270.     (let ((hit2 (mouse-second-hit extra-click-wait)))
  271.       (if hit2    ; we cons'd it, we can smash it.
  272.           ; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...))
  273.           (setcar hit1 (logior (sm::hit-code hit1) 
  274.                    (sm::hit-code hit2)
  275.                    (if (= (sm::hit-button hit1) 
  276.                       (sm::hit-button hit2))
  277.                        sm::DoubleBits 0))))))
  278.     hit1))
  279.  
  280. (defun mouse-hit-read ()
  281.   "Read mouse-hit list from keyboard.  Like (read 'read-char),
  282. but that uses minibuffer, and mucks up last-command."
  283.   (let ((char-list nil) (char nil))
  284.     (while (not (equal 13        ; Carriage return.
  285.                (prog1 (setq char (read-char)) 
  286.              (setq char-list (cons char char-list))))))
  287.     (read (mapconcat 'char-to-string (nreverse char-list) ""))
  288.     ))
  289.  
  290. ;;; Second Click Hackery....
  291. ;;; if prefix is not mouse-prefix, need a way to unread the char...
  292. ;;; or else have mouse flush input queue, or else need a peek at next char.
  293.  
  294. ;;; There is no peek, but since one character can be unread, we only
  295. ;;; have to flush the queue when the command after a mouse click
  296. ;;; starts with mouse-prefix1 (see below).
  297. ;;;   Something to do later:  We could buffer the read commands and
  298. ;;; execute them ourselves after doing the mouse command (using
  299. ;;; lookup-key ??).
  300.  
  301. (defvar mouse-prefix1 24        ; C-x
  302.   "First char of mouse-prefix.  Used to detect double clicks and chords.")
  303.  
  304. (defvar mouse-prefix2 0            ; C-@
  305.   "Second char of mouse-prefix.  Used to detect double clicks and chords.")
  306.  
  307.  
  308. (defun mouse-second-hit (hit-wait)
  309.   "Returns the next mouse hit occurring within HIT-WAIT milliseconds."
  310.   (if (sit-for-millisecs hit-wait) nil    ; No input within hit-wait millisecs.
  311.     (let ((pc1 (read-char)))
  312.       (if (or (not (equal pc1 mouse-prefix1))
  313.           (sit-for-millisecs 3))    ; a mouse prefix will have second char
  314.       (progn (setq unread-command-char pc1)    ; Can get away with one unread.
  315.          nil)            ; Next input not mouse event.
  316.     (let ((pc2 (read-char)))
  317.       (if (not (equal pc2 mouse-prefix2))
  318.           (progn (setq unread-command-char pc1) ; put back the ^X
  319. ;;; Too bad can't do two: (setq unread-command-char (list pc1 pc2))
  320.         (ding)            ; user will have to retype that pc2.
  321.         nil)            ; This input is not a mouse event.
  322.         ;; Next input has mouse prefix and is within time limit.
  323.         (let ((new-hit (mouse-hit-read))) ; Read the new hit.
  324.         (if (sm::hit-up-p new-hit)    ; Ignore up events when timing.
  325.             (mouse-second-hit (- hit-wait (sm::hit-delta new-hit)))
  326.           new-hit        ; New down hit within limit, return it.
  327.           ))))))))
  328.  
  329. (defun sm::window-xy (x y)
  330.   "Find window containing screen coordinates X and Y.
  331. Returns list (window x y) where x and y are relative to window."
  332.   (or
  333.    (catch 'found
  334.      (eval-in-windows 
  335.       (let ((we (window-edges (selected-window))))
  336.     (let ((le (nth 0 we))
  337.           (te (nth 1 we))
  338.           (re (nth 2 we))
  339.           (be (nth 3 we)))
  340.       (if (= re (screen-width))
  341.           ;; include the continuation column with this window
  342.           (setq re (1+ re)))
  343.       (if (= be (screen-height))
  344.           ;; include partial line at bottom of screen with this window
  345.           ;; id est, if window is not multple of char size.
  346.           (setq be (1+ be)))
  347.  
  348.       (if (and (>= x le) (< x re)
  349.            (>= y te) (< y be))
  350.           (throw 'found 
  351.              (list (selected-window) (- x le) (- y te))))))
  352.       t))                ; include minibuffer in eval-in-windows
  353.    ;;If x,y from a real mouse click, we shouldn't get here.
  354.    (list nil x y)
  355.    ))
  356.  
  357. (defun sm::window-region (loc)
  358.   "Parse LOC into a region symbol.
  359. Returns one of (text scrollbar modeline minibuffer)"
  360.   (let ((w (sm::loc-w loc))
  361.     (x (sm::loc-x loc))
  362.     (y (sm::loc-y loc)))
  363.     (let ((right (1- (window-width w)))
  364.       (bottom (1- (window-height w))))
  365.       (cond ((minibuffer-window-p w) 'minibuffer)
  366.         ((>= y bottom) 'modeline)
  367.         ((>= x right) 'scrollbar)
  368.         ;; far right column (window seperator) is always a scrollbar
  369.         ((and scrollbar-width
  370.           ;; mouse within scrollbar-width of edge.
  371.           (>= x (- right scrollbar-width))
  372.           ;; mouse a few chars past the end of line.
  373.           (>= x (+ 2 (window-line-end w x y))))
  374.          'scrollbar)
  375.         (t 'text)))))
  376.  
  377. (defun window-line-end (w x y)
  378.   "Return WINDOW column (ignore X) containing end of line Y"
  379.   (eval-in-window w (save-excursion (move-to-loc (screen-width) y))))
  380.  
  381. ;;;
  382. ;;; The encoding of mouse events into a mousemap.
  383. ;;; These values must agree with coding in emacstool:
  384. ;;;
  385. (defconst sm::keyword-alist 
  386.   '((left . 1) (middle . 2) (right . 4)
  387.     (shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128)
  388.     (text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048)
  389.     ))
  390.  
  391. (defun mouse-event-code (hit loc)
  392.   "Maps MOUSE-HIT and LOC into a mouse-code."
  393. ;;;Region is a code for one of text, modeline, scrollbar, or minibuffer.
  394.   (logior (sm::hit-code hit)
  395.       (mouse-region-to-code (sm::window-region loc))))
  396.  
  397. (defun mouse-region-to-code (region)
  398.   "Returns partial mouse-code for specified REGION."
  399.   (cdr (assq region sm::keyword-alist)))
  400.  
  401. (defun mouse-list-to-mouse-code (mouse-list)
  402.   "Map a MOUSE-LIST to a mouse-code."
  403.   (apply 'logior
  404.      (mapcar (function (lambda (x)
  405.                  (cdr (assq x sm::keyword-alist))))
  406.           mouse-list)))
  407.  
  408. (defun mouse-code-to-mouse-list (mouse-code)
  409.   "Map a MOUSE-CODE to a mouse-list."
  410.   (apply 'nconc (mapcar
  411.          (function (lambda (x)
  412.                  (if (logtest mouse-code (cdr x))
  413.                  (list (car x)))))
  414.          sm::keyword-alist)))
  415.  
  416. (defun mousemap-set (code mousemap value)
  417.   (let* ((alist (cdr mousemap))
  418.      (assq-result (assq code alist)))
  419.     (if assq-result
  420.     (setcdr assq-result value)
  421.       (setcdr mousemap (cons (cons code value) alist)))))
  422.  
  423. (defun mousemap-get (code mousemap)
  424.   (cdr (assq code (cdr mousemap))))
  425.  
  426. (defun mouse-lookup (mouse-code)
  427.   "Look up MOUSE-EVENT and return the definition. nil means undefined."
  428.   (or (mousemap-get mouse-code current-local-mousemap)
  429.       (mousemap-get mouse-code current-global-mousemap)))
  430.  
  431. ;;;
  432. ;;; I (jpeck) don't understand the utility of the next four functions
  433. ;;; ask Steven Greenbaum <froud@kestrel>
  434. ;;;
  435. (defun mouse-mask-lookup (mask list)
  436.   "Args MASK (a bit mask) and LIST (a list of (code . form) pairs).
  437. Returns a list of elements of LIST whose code or'ed with MASK is non-zero."
  438.   (let ((result nil))
  439.     (while list
  440.       (if (logtest mask (car (car list)))
  441.       (setq result (cons (car list) result)))
  442.       (setq list (cdr list)))
  443.     result))
  444.  
  445. (defun mouse-union (l l-unique)
  446.   "Return the union of list of mouse (code . form) pairs L and L-UNIQUE,
  447. where L-UNIQUE is considered to be union'ized already."
  448.   (let ((result l-unique))
  449.     (while l
  450.       (let ((code-form-pair (car l)))
  451.     (if (not (assq (car code-form-pair) result))
  452.         (setq result (cons code-form-pair result))))
  453.       (setq l (cdr l)))
  454.     result))
  455.  
  456. (defun mouse-union-first-prefered (l1 l2)
  457.   "Return the union of lists of mouse (code . form) pairs L1 and L2,
  458. based on the code's, with preference going to elements in L1."
  459.   (mouse-union l2 (mouse-union l1 nil)))
  460.  
  461. (defun mouse-code-function-pairs-of-region (region)
  462.   "Return a list of (code . function) pairs, where each code is
  463. currently set in the REGION."
  464.   (let ((mask (mouse-region-to-code region)))
  465.     (mouse-union-first-prefered
  466.      (mouse-mask-lookup mask (cdr current-local-mousemap))
  467.      (mouse-mask-lookup mask (cdr current-global-mousemap))
  468.      )))
  469.  
  470. ;;;
  471. ;;; Functions for DESCRIBE-MOUSE-BINDINGS
  472. ;;; And other mouse documentation functions
  473. ;;; Still need a good procedure to print out a help sheet in readable format.
  474. ;;;
  475.  
  476. (defun one-line-doc-string (function)
  477.   "Returns first line of documentation string for FUNCTION.
  478. If there is no documentation string, then the string
  479. \"No documentation\" is returned."
  480.   (while (consp function) (setq function (car function)))
  481.   (let ((doc (documentation function)))
  482.     (if (null doc)
  483.     "No documentation."
  484.       (string-match "^.*$" doc)
  485.       (substring doc 0 (match-end 0)))))
  486.  
  487. (defun print-mouse-format (binding)
  488.   (princ (car binding))
  489.   (princ ": ")
  490.   (mapcar (function
  491.        (lambda (mouse-list)
  492.          (princ mouse-list)
  493.          (princ " ")))
  494.       (cdr binding))
  495.   (terpri)
  496.   (princ "  ")
  497.   (princ (one-line-doc-string (car binding)))
  498.   (terpri)
  499.   )
  500.  
  501. (defun print-mouse-bindings (region)
  502.   "Prints mouse-event bindings for REGION."
  503.   (mapcar 'print-mouse-format (sm::event-bindings region)))
  504.  
  505. (defun sm::event-bindings (region)
  506.   "Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION,
  507. where each mouse-list is bound to the function in REGION."
  508.   (let ((mouse-bindings (mouse-code-function-pairs-of-region region))
  509.     (result nil))
  510.     (while mouse-bindings
  511.       (let* ((code-function-pair (car mouse-bindings))
  512.          (current-entry (assoc (cdr code-function-pair) result)))
  513.     (if current-entry
  514.         (setcdr current-entry
  515.             (cons (mouse-code-to-mouse-list (car code-function-pair))
  516.               (cdr current-entry)))
  517.       (setq result (cons (cons (cdr code-function-pair)
  518.                    (list (mouse-code-to-mouse-list
  519.                       (car code-function-pair))))
  520.                  result))))
  521.       (setq mouse-bindings (cdr mouse-bindings))
  522.       )
  523.     result))
  524.  
  525. (defun describe-mouse-bindings ()
  526.   "Lists all current mouse-event bindings."
  527.   (interactive)
  528.   (with-output-to-temp-buffer "*Help*"
  529.     (princ "Text Region") (terpri)
  530.     (princ "---- ------") (terpri)
  531.     (print-mouse-bindings 'text) (terpri)
  532.     (princ "Modeline Region") (terpri)
  533.     (princ "-------- ------") (terpri)
  534.     (print-mouse-bindings 'modeline) (terpri)
  535.     (princ "Scrollbar Region") (terpri)
  536.     (princ "--------- ------") (terpri)
  537.     (print-mouse-bindings 'scrollbar)))
  538.  
  539. (defun describe-mouse-briefly (mouse-list)
  540.   "Print a short description of the function bound to MOUSE-LIST."
  541.   (interactive "xDescibe mouse list briefly: ")
  542.   (let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list))))
  543.     (if function
  544.     (message "%s runs the command %s" mouse-list function)
  545.       (message "%s is undefined" mouse-list))))
  546.  
  547. (defun mouse-help-menu (function-and-binding)
  548.   (cons (prin1-to-string (car function-and-binding))
  549.     (menu-create    ; Two sub-menu items of form ("String" . nil)
  550.      (list (list (one-line-doc-string (car function-and-binding)))
  551.            (list (prin1-to-string (cdr function-and-binding)))))))
  552.  
  553. (defun mouse-help-region (w x y &optional region)
  554.   "Displays a menu of mouse functions callable in this region."
  555.   (let* ((region (or region (sm::window-region (list w x y))))
  556.      (mlist (mapcar (function mouse-help-menu)
  557.             (sm::event-bindings region)))
  558.      (menu (menu-create (cons (list (symbol-name region)) mlist)))
  559.      (item (sun-menu-evaluate w 0 y menu))
  560.      )))
  561.  
  562. ;;;
  563. ;;; Menu interface functions
  564. ;;;
  565. ;;; use defmenu, because this interface is subject to change
  566. ;;; really need a menu-p, but we use vectorp and the context...
  567. ;;;
  568. (defun menu-create (items)
  569.   "Functional form for defmenu, given a list of ITEMS returns a menu.
  570. Each ITEM is a (STRING . VALUE) pair."
  571.   (apply 'vector items)
  572.   )
  573.  
  574. (defmacro defmenu (menu &rest itemlist)
  575.   "Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs.
  576. See sun-menu-evaluate for interpretation of ITEMS."
  577.   (list 'defconst menu (funcall 'menu-create itemlist))
  578.   )
  579.  
  580. (defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu)
  581.   "Display a pop-up menu in WINDOW at X Y and evaluate selected item
  582. of MENU.  MENU (or its symbol-value) should be a menu defined by defmenu.
  583.   A menu ITEM is a (STRING . FORM) pair;
  584. the FORM associated with the selected STRING is evaluated,
  585. and the resulting value is returned.  Generally these FORMs are
  586. evaluated for their side-effects rather than their values.
  587.   If the selected form is a menu or a symbol whose value is a menu, 
  588. then it is displayed and evaluated as a pullright menu item.
  589.   If the the FORM of the first ITEM is nil, the STRING of the item
  590. is used as a label for the menu, i.e. it's inverted and not selectible."
  591.  
  592.   (if (symbolp menu) (setq menu (symbol-value menu)))
  593.   (eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu)))
  594.  
  595. (defun sun-get-frame-data (code)
  596.   "Sends the tty-sub-window escape sequence CODE to terminal,
  597. and returns a cons of the two numbers in returned escape sequence.
  598. That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\". 
  599. CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars."
  600.   (send-string-to-terminal (concat "\033[" (int-to-string code) "t"))
  601.   (let (char str x y)
  602.     (while (not (equal 116 (setq char (read-char)))) ; #\t = 116
  603.       (setq str (cons char str)))
  604.     (setq str (mapconcat 'char-to-string (nreverse str) ""))
  605.     (string-match ";[0-9]*" str)
  606.     (setq y (substring str (1+ (match-beginning 0)) (match-end 0)))
  607.     (setq str (substring str (match-end 0)))
  608.     (string-match ";[0-9]*" str)
  609.     (setq x (substring str (1+ (match-beginning 0)) (match-end 0)))
  610.     (cons (string-to-int y) (string-to-int x))))
  611.  
  612. (defun sm::font-size ()
  613.   "Returns font size in pixels: (cons Ysize Xsize)"
  614.   (let ((pix (sun-get-frame-data 14))    ; returns size in pixels
  615.     (chr (sun-get-frame-data 18)))    ; returns size in chars
  616.     (cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr)))))
  617.  
  618. (defvar sm::menu-kludge-x nil 
  619.   "Cached frame-to-window X-Offset for sm::menu-kludge")
  620. (defvar sm::menu-kludge-y nil 
  621.   "Cached frame-to-window Y-Offset for sm::menu-kludge")
  622.  
  623. (defun sm::menu-kludge ()
  624.   "If sunfns.c uses <Menu_Base_Kludge> this function must be here!"
  625.   (or sm::menu-kludge-y
  626.       (let ((fs (sm::font-size)))
  627.     (setq sm::menu-kludge-y (+ 8 (car fs))    ; a title line and borders
  628.           sm::menu-kludge-x 4)))    ; best values depend on .defaults/Menu
  629.   (let ((wl (sun-get-frame-data 13)))        ; returns frame location
  630.     (cons (+ (car wl) sm::menu-kludge-y)
  631.       (+ (cdr wl) sm::menu-kludge-x))))
  632.  
  633. ;;;
  634. ;;;  Function interface to selection/region
  635. ;;;  primative functions are defined in sunfns.c
  636. ;;;
  637. (defun sun-yank-selection ()
  638.   "Set mark and yank the contents of the current sunwindows selection
  639. into the current buffer at point."
  640.   (interactive "*")
  641.   (set-mark-command nil)
  642.   (insert-string (sun-get-selection)))
  643.  
  644. (defun sun-select-region (beg end)
  645.   "Set the sunwindows selection to the region in the current buffer."
  646.   (interactive "r")
  647.   (sun-set-selection (buffer-substring beg end)))
  648.  
  649. ;;;
  650. ;;; Support for emacstool
  651. ;;; This closes the window instead of stopping emacs.
  652. ;;;
  653. (defun suspend-emacstool (&optional stuffstring)
  654.   "If running under as a detached process emacstool,
  655. you don't want to suspend  (there is no way to resume), 
  656. just close the window, and wait for reopening."
  657.   (interactive)
  658.   (if (and (boundp 'suspend-hook) suspend-hook)
  659.       (funcall suspend-hook))
  660.   (if stuffstring (send-string-to-terminal stuffstring))
  661.   (send-string-to-terminal "\033[2t")    ; To close EmacsTool window.
  662.   (if (and (boundp 'suspend-resume-hook) suspend-resume-hook)
  663.       (funcall suspend-resume-hook)))
  664. ;;;
  665. ;;; initialize mouse maps
  666. ;;;
  667.  
  668. (make-variable-buffer-local 'current-local-mousemap)
  669. (setq-default current-local-mousemap nil)
  670. (defvar current-global-mousemap (make-mousemap))
  671.